Visual Basic Controls/Visual Basic Controls.iso/vbcontrol/edgetext/clsdataa.cl_/clsdataa.cl

Visual Basic class definition | 1998-03-30 | 20.4 KB | 550 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
End
Attribute VB_Name = "clsDataAccess"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'********************************************************************************************************
'Title:     clsDataAccess
'Author:    DesignGrid by W. David Ewing, Copyright 1998
'Purpose    This class was created to wrap SQL data access for error checking and ease of programming
'Requires:  frmLogon.frm
'
'This is commented because it is recommended that objError be declared global
'The reason for this is so that the DisplayFlag and writeToFile properties will
'be persistent
'Private objError as new clsError
'
'It is recommended that the Database object Dbtimesheet be declared global

'It is also recommended that the Configuration object be declared global if it is being used
'This is so that it can be persistent
'**************************************************************************************

Public Success as Boolean
Public ErrorCode as Double
Public ErrorMessage as string


'********************************************************************************************************
'Title:     GetNewId
'Author:    DesignGrid by W. David Ewing, Copyright 1998
'Purpose    This Function is uses a three field table called UNIQUE_ID to generate unique key numbers
'           It is intended for use with databases which do not contain such a facility internally
'Parameters:The Table Name for the key, and the field name where the key is found
'Return:    sequential double type key value
'********************************************************************************************************
Public Function GetNewId(psTableName As String, psKeyFieldName As String) As Double

Dim lrsData As Recordset
Dim lsSelect as String, ldCurVal as Double, RetryCounter as integer
Dim liCount as integer, BadCount as integer, Retries as integer

    'Convert to Uppercase for consistency
    psTableName = UCase(Trim(psTableName))
    psKeyFieldName = UCase(Trim(psKeyFieldName))
    'Try 10 Times to get a key, this is abritrary and may be adjusted up or down according to server use
    Retries = 10
    RetryCounter = 0
    'Loop until a new entry can be inserted
    Do
        'Get the current Highest Entry, speed is pretty good because of the index
        lsSelect = "Select Max(UNIQUE_NUMBER) from UNIQUE_ID where TABLE_NAME = '" & psTableName & "' and FIELD_NAME = '" & psKeyFieldName & "'"
        Set lrsData = OpenNewRecordSet(lsSelect)
        'If no entry is found then init the counter to 1; otherwise, increment the current value by 1
        if Success then
            If Not Isnull(lrsData(0)) then
                ldCurVal = lrsData(0) + 1
            Else
                ldCurVal = 1
            End If
            lrsData.Close
        Else
            ldCurVal = 1
        End If
        'by attempting an insert into a table called UNIQUE_ID where the key is all three fields, TABLE_NAME+FIELD_NAME+UNIQUE_NUMBER
        'only one user will be successful at a time with the insert
        'You may want to establish housekeeping on this table to erase old entries, it could grow large
        lsSelect = "insert into UNIQUE_ID values('" & psTableName & "', '" & psKeyFieldName & "', ldCurVal)"
        dbExecute lsSelect
        RetryCounter = RetryCounter + 1
    Loop While Not Success and RetryCounter < Retries
    if Success then
        GetNewId = ldCurVal
    else
        GetNewId = 0
    End If

End Function

'********************************************************************************************************
'Title:     OpenGlobalDatabase
'Author:    DesignGrid by W. David Ewing, Copyright 1998
'Purpose    This Function will open a database for an ODBC datasource.  It will also
'           pop a login screen if the logonrequired flag is set or if the parameters
'           which are provided to the function are not successful at opening the database.
'           By default, it uses the configuration class DataSource, UserId and Password
'           properties for the sign on information.
'Parameters:Database to be opened, and logon required flag
'Return:    True on Success, False on Fail
'********************************************************************************************************
Public Function OpenGlobalDB(Dbtimesheet as Database, pLogonRequired As Integer)

Dim RetCode As Integer

    Success = False
    ErrorCode = False
    RetCode = True

    'if the required flag is set then
    'display the logon screen
    If pLogonRequired Then
        Screen.MousePointer = vbNormal
        frmLogon.txtLogonName = objConfiguration.LogonName
        frmLogon.txtDataSource = Objconfiguration.datasource

        frmLogon.Show vbModal
        If frmLogon.Cancel Then
            OpenGlobalDB = False
            Exit Function
        End If

        Screen.MousePointer = vbHourglass
        Objconfiguration.datasource = frmLogon.txtDataSource
        objConfiguration.LogonName = frmLogon.txtLogonName
        objConfiguration.Password = frmLogon.txtPassword
    End If

    On Error goto OpenFCErrors
    'loop until connection or user abort
    Do While Not Success
        Success = True
        'Try to Open the Database
        Set Dbtimesheet = OpenDatabase(Objconfiguration.datasource)
        If Not RetCode Then
            'this shows the user pressed cancel on the Logon form
            'just get out
            OpenGlobalDB = False
            Exit Function
        End If
        If Success Then
            Exit Do
        End If
    Loop

    OpenGlobalDB = Success
    On Error GoTo 0
    If Not Success Then
        Exit Function
    End If

    Exit Function

OpenFCErrors:
    'flag the above code
    Success = False
    ErrorCode = Err
    Screen.MousePointer = vbNormal
    'ask the user for the database path
    frmLogon.txtDataSource = Objconfiguration.datasource
    frmLogon.txtLogonName = objConfiguration.LogonName
    frmLogon.txtPassword = objConfiguration.Password
    frmLogon.Cancel = False
    Screen.MousePointer = vbNormal
    frmLogon.Show vbModal
    If frmLogon.Cancel = True Then
        'if the user cancels the action, return a successful code
        'and no error code, but exit the function and put a false on the function return
        Success = True
        ErrorCode = False
        RetCode = False
    End If
    Objconfiguration.datasource = frmLogon.txtDataSource
    objConfiguration.LogonName = frmLogon.txtLogonName
    objConfiguration.Password = frmLogon.txtPassword
    'Return
    Resume Next

End Function

'********************************************************************************************************
'Title:     OpenRecordSetWithRecs
'Author:    DesignGrid by W. David Ewing, Copyright 1998
'Purpose    This Function will open recordset using the SQL passed into the function.
'           if all goes well it returns a valid recordset, if it is not successful or
'           there are no records in the recordset then it sets the recordset to NOTHING
'           so that the programmer can simultaneously check for records or errors by seeing if it is set to NOTHING
'Parameters:SQL to be used in the recordset
'Return:    valid recordset on success or recs found, NOTHING on failure or no recs
'********************************************************************************************************
Public Function OpenRecordSetWithRecs(psSQL As String) As Recordset

Dim lrsData As Recordset
Dim liCount as integer, BadCount as integer, lsSelect as String

    'The Success flag gets initialized to True and set to false if a trappable error occurs
    Success = True
    'The ErrorCode is the Err returned by VB for the Trapped Error
    ErrorCode = False
    'The DebugFlag is the provision which turns off all error checking in the table class when false
    If Not objConfiguration.DebugFlag Then
        On Error GoTo NoDataAccessOpenRecordSetWithRecs
    End If

    lsSelect = psSQL
    'Execute the SQL
    Set lrsData = Dbtimesheet.OpenRecordSet(lsSelect, dbOpenSnapShot)

    'if we were able to open the recordset, but there are no recs, just set it to nothing anyway
    'the success flag will remain true and error code false
    If Success Then
        If lrsData.RecordCount = 0 Then
            Set OpenRecordSetWithRecs = Nothing
        End If
    End If
    Set OpenRecordSetWithRecs = lrsData
    On Error GoTo 0
    Exit Function

NoDataAccessOpenRecordSetWithRecs:

    Success = False
    ErrorCode = Err
    objError.ErrorCode = Err
    objError.FunctionName = "clsDataAccess.OpenRecordSetWithRecs"
    If Err = 3146 then
        objError.Message = "DataAccess, OpenRecordSetWithRecs " & vbcrlf & Errors(0) & " "
        ErrorMessage = Errors(0)
    Else
        objError.Message = "DataAccess, OpenRecordSetWithRecs "
        ErrorMessage = Error(Err)
    End If
    objError.SQL = lsSelect
    objError.Display vbExclamation
    Resume Next


End Function

'********************************************************************************************************
'Title:     OpenNewRecordSet
'Author:    DesignGrid by W. David Ewing, Copyright 1998
'Purpose    This Function will open recordset using the SQL passed into the function.
'           This is similar to the OpenRecordsetWithRecs, but it only returns NOTHING
'           when there is an error.  It will return a valid empty recordset if no
'           records are found
'Parameters:SQL to be used in the recordset
'Return:    valid recordset on success, NOTHING on failure
'********************************************************************************************************
Public Function OpenNewRecordSet(psSQL As String) As Recordset

Dim lrsData As Recordset
Dim liCount as integer, BadCount as integer, lsSelect as String

    'The Success flag gets initialized to True and set to false if a trappable error occurs
    Success = True
    'The ErrorCode is the Err returned by VB for the Trapped Error
    ErrorCode = False
    'The DebugFlag is the provision which turns off all error checking in the table class when false
    If Not objConfiguration.DebugFlag Then
        On Error GoTo NoDataAccessOpenNewRecordSet
    End If

    lsSelect = psSQL
    'Execute the SQL
    Set lrsData = Dbtimesheet.OpenRecordSet(lsSelect, dbOpenSnapShot)

    Set OpenNewRecordSet = lrsData
    On Error GoTo 0
    Exit Function

NoDataAccessOpenNewRecordSet:

    Success = False
    ErrorCode = Err
    objError.ErrorCode = Err
    objError.FunctionName = "clsDataAccess.OpenNewRecordSet"
    If Err = 3146 then
        objError.Message = "DataAccess, OpenNewRecordSet " & vbcrlf & Errors(0) & " "
        ErrorMessage = Errors(0)
    Else
        objError.Message = "DataAccess, OpenNewRecordSet "
        ErrorMessage = Error(Err)
    End If
    objError.SQL = lsSelect
    objError.Display vbExclamation
    Resume Next


End Function

'********************************************************************************************************
'Title:     GetFieldTypeString
'Author:    DesignGrid by W. David Ewing, Copyright 1998
'Purpose    This Function will return a string based on the microsoft field type value passed in
'Parameters:Field Type as Integer
'Return:    Field Type String to Display
'********************************************************************************************************
Public Function GetFieldTypeString(piFieldType As Integer) as String

Dim lsBuf As String

    Success = True
    ErrorCode = False
    Select Case piFieldType
        Case dbBoolean
            lsBuf = "Boolean"
        Case dbByte
            lsBuf = "Byte"
        Case dbInteger
            lsBuf = "Integer"
        Case dbLong
            lsBuf = "Long"
        Case dbCurrency
            lsBuf = "Currency"
        Case dbSingle
            lsBuf = "Single"
        Case dbDouble
            lsBuf = "Double"
        Case dbDate
            lsBuf = "Date/Time"
        Case 9
            lsBuf = "Reserved 9"
        Case dbText
            lsBuf = "Text"
        Case dbBinary
            lsBuf = "Binary"
        Case dbMemo
            lsBuf = "Memo"
        Case Else
            lsBuf = "Unknown"
    End Select
    GetFieldTypeString = lsBuf

End Function

'********************************************************************************************************
'Title:     GetFieldTypeFromString
'Author:    DesignGrid by W. David Ewing, Copyright 1998
'Purpose    This Function will return a Microsoft field type based on the string passed in
'Parameters:Field Type as string
'Return:    Microsoft Field Type Integer
'********************************************************************************************************
Public Function GetFieldTypeFromString(psFieldType As String) As Integer

Dim liBuf As Integer

    Success = True
    ErrorCode = False
    Select Case UCase(Trim(psFieldType))
        Case "BOOLEAN"
            liBuf = dbBoolean
        Case "BYTE"
            liBuf = dbByte
        Case "INTEGER"
            liBuf = dbInteger
        Case "LONG"
            liBuf = dbLong
        Case "CURRENCY"
            liBuf = dbCurrency
        Case "SINGLE"
            liBuf = dbSingle
        Case "DOUBLE"
            liBuf = dbDouble
        Case "DATE","DATE/TIME"
            liBuf = dbDate
        Case "RESERVED 9"
            liBuf = 9
        Case "TEXT","STRING"
            liBuf = dbText
        Case "BINARY"
            liBuf = dbBinary
        Case "MEMO"
            liBuf = dbMemo
        Case Else
            liBuf = True
    End Select
    GetFieldTypeFromString = liBuf

End Function

'********************************************************************************************************
'Title:     dbExecute
'Author:    DesignGrid by W. David Ewing, Copyright 1998
'Purpose    This Sub will Execute an SQL statement which is passed in
'Parameters:SQL statement to execute
'Return:    Success property is set to true if sucessful false if unsuccessful
'********************************************************************************************************
Public Sub dbExecute(psSQL As String)

Dim liCount as integer,BadCount as integer, lsSelect as String

    'The Success flag gets initialized to True and set to false if a trappable error occurs
    Success = True
    'The ErrorCode is the Err returned by VB for the Trapped Error
    ErrorCode = False
    'The DebugFlag is the provision which turns off all error checking in the table class when false
    If Not objConfiguration.DebugFlag Then
        On Error GoTo NoDataAccessdbExecute
    End If
    Dbtimesheet.Execute psSQL
    On Error GoTo 0
    Exit Sub

    lsSelect = psSQL
NoDataAccessdbExecute:

    Success = False
    ErrorCode = Err
    objError.ErrorCode = Err
    objError.FunctionName = "clsDataAccess.dbExecute"
    If Err = 3146 then
        objError.Message = "DataAccess, dbExecute " & vbcrlf & Errors(0) & " "
        ErrorMessage = Errors(0)
    Else
        objError.Message = "DataAccess, dbExecute "
        ErrorMessage = Error(Err)
    End If
    objError.SQL = lsSelect
    objError.Display vbExclamation
    Resume Next


End Sub

'********************************************************************************************************
'Title:     SearchandDouble
'Author:    DesignGrid by W. David Ewing, Copyright 1998
'Purpose:   This Function will look for any single quotes in a string passed to it
'           and double them for SQL compatibility
'Parameters:string to be modified
'Return:    the modified string
'********************************************************************************************************
Public Function SearchandDouble(lsBuf As String) As String

Dim liStrLen As Integer
Dim liCurChar As Integer
Dim liQuotePos As Integer
Dim lsQuote As String
Dim lsOutBuf As String

    lsQuote = "'"
    liCurChar = 1
    lsOutBuf = ""


    liQuotePos = InStr(liCurChar, lsBuf, lsQuote)
    If liQuotePos = 0 Then
        lsOutBuf = lsBuf
    Else
        liStrLen = Len(lsBuf)
        Do While liQuotePos > 0
            lsOutBuf = lsOutBuf & Mid(lsBuf, liCurChar, liQuotePos - liCurChar + 1) & lsQuote
            liCurChar = liQuotePos + 1
            liQuotePos = InStr(liCurChar, lsBuf, lsQuote)
        Loop
        lsOutBuf = lsOutBuf & Mid(lsBuf, liCurChar, liStrLen)
    End If

    SearchandDouble = lsOutBuf

End Function
'********************************************************************************************************
'Title:     GetSingleField
'Author:    DesignGrid by W. David Ewing, Copyright 1998
'Purpose:   This method gets a single field from the database with the SQL passed in
'Parameters:SQL to execute
'Return:    return value
'********************************************************************************************************
Public Function GetSingleField(psSQL As String) As Variant

Dim lrsData As Recordset
Dim liCount As Integer, lsSelect as string,BadCount as Integer


    'The Success flag gets initialized to True and set to false if a trappable error occurs
    Success = True
    'The ErrorCode is the Err returned by VB for the Trapped Error
    ErrorCode = False
    'The DebugFlag is the provision which turns off all error checking in the table class when false
    If Not objConfiguration.DebugFlag Then
        On Error GoTo NoDataAccessGetSingleField
    End If

    lsSelect = psSQL
    'Execute the SQL
    Set lrsData = Dbtimesheet.OpenRecordSet(lsSelect, dbOpenSnapShot)

    'if we were able to open the recordset, but there are no recs, just set it to nothing anyway
    'the success flag will remain true and error code false
    If Success Then
        'check the field type and return the appropriate data
        If lrsData.RecordCount = 0 Then
            If lrsData(0).Type = dao.dbText Or lrsData(0).Type = dao.dbDate Or _
               lrsData(0).Type = dao.dbTime Or lrsData(0).Type = dao.dbChar _
               Or lrsData(0).Type = dao.dbMemo Then
               'see if it is a date
               If lrsData(0).Type = dbDate Then
                  'This check is here in case you would like to have this method return a default date such as 01/01/1800
                  GetSingleField = ""
               Else
                  GetSingleField = ""
               End If
            Else
               GetSingleField = 0
            End If
        Else
            'check the field type and return the appropriate data
            If lrsData(0).Type = dao.dbText Or lrsData(0).Type = dao.dbDate Or _
               lrsData(0).Type = dao.dbTime Or lrsData(0).Type = dao.dbChar _
               Or lrsData(0).Type = dao.dbMemo Then
               'see if this is a date
               If lrsData(0).Type = dbDate Then
                  'see if there is a time of day required
                  If not isnull(lrsData(0)) then
                     If CDate(Format(lrsData(0), "mm/dd/yyyy hh:mm:ss")) - CDate(Format(lrsData(0), "mm/dd/yyyy")) = 0 Then
                        'no need to show time of day
                        GetSingleField = Format(lrsData(0), "mm/dd/yyyy")
                     Else
                        GetSingleField = Format(lrsData(0), "mm/dd/yyyy hh:mm:ss")
                     End If
                  Else
                      GetSingleField = ""
                  End If
               Else
                  GetSingleField = lrsData(0) & ""
               End If
            Else
               GetSingleField = Val(lrsData(0) & "")
            End If
            lrsData.Close
        End If
    Else
        GetSingleField = ""
    End If
    On Error GoTo 0
    Exit Function
NoDataAccessGetSingleField:

    Success = False
    ErrorCode = Err
    objError.ErrorCode = Err
    objError.FunctionName = "clsDataAccess.GetSingleField"
    If Err = 3146 then
        objError.Message = "DataAccess, GetSingleField " & vbcrlf & Errors(0) & " "
        ErrorMessage = Errors(0)
    Else
        objError.Message = "DataAccess, GetSingleField "
        ErrorMessage = Error(Err)
    End If
    objError.SQL = lsSelect
    objError.Display vbExclamation
    Resume Next

End Function